home *** CD-ROM | disk | FTP | other *** search
- Path: uunet!husc6!mit-eddie!uw-beaver!tektronix!tekgen!tekred!games-request
- From: games-request@tekred.TEK.COM
- Newsgroups: comp.sources.games
- Subject: v03i099: go - go board manager sources, Part03/05
- Message-ID: <2270@tekred.TEK.COM>
- Date: 9 Mar 88 17:57:05 GMT
- Sender: billr@tekred.TEK.COM
- Lines: 2210
- Approved: billr@tekred.TEK.COM
-
- Submitted by: Fred Hansen <wjh+@andrew.cmu.edu>
- Comp.sources.games: Volume 3, Issue 99
- Archive-name: go/Part03
-
-
-
- #! /bin/sh
- # This is a shell archive. Remove anything before this line, then unpack
- # it by saving it into a file and typing "sh file". To overwrite existing
- # files, type "sh file -c". You can also feed this as standard input via
- # unshar, or by typing "sh <file", e.g.. If this archive is complete, you
- # will see the following message at the end:
- # "End of archive 3 (of 5)."
- # Contents: goBoard.pas goTree.pas
- # Wrapped by billr@saab on Wed Mar 9 09:14:45 1988
- PATH=/bin:/usr/bin:/usr/ucb ; export PATH
- if test -f goBoard.pas -a "${1}" != "-c" ; then
- echo shar: Will not over-write existing file \"goBoard.pas\"
- else
- echo shar: Extracting \"goBoard.pas\" \(38053 characters\)
- sed "s/^X//" >goBoard.pas <<'END_OF_goBoard.pas'
- X{---------------------------------------------------------------}
- X{ goBoard.Pas }
- X{ }
- X{ Board Image Handler for Go }
- X{ Copyright (c) 1982 by Three Rivers Computer Corp. }
- X{ }
- X{ Written: June 3, 1982 by Stoney Ballard }
- X{ Edit History: }
- X{ June 3, 1982 Started }
- X{ June 4, 1982 Add dead group removal }
- X{ June 10, 1982 Use new go file manager }
- X{ Nov 8, 1982 Split From Go.Pas }
- X{---------------------------------------------------------------}
- X
- X
- Xmodule goBoard;
- X
- Xexports
- X
- Ximports goCom from goCom;
- Ximports screen from screen;
- X
- Xtype
- X SoundType = (atari, koV, s3, s4, die, die2, die3, error);
- X
- Xexception gbFatal;
- X
- Xprocedure initGoBoard;
- Xprocedure clearBoard;
- Xprocedure addHCStones(num: integer);
- Xprocedure placeStone(which: sType; lx, ly, ofx, ofy, moveNum: integer);
- Xprocedure placeAlt(which: sType; lx, ly, ofx, ofy: integer);
- Xprocedure remStone(lx, ly: integer);
- Xprocedure showPass(which: sType);
- Xprocedure remPass;
- Xfunction passLocCur(cx, cy: integer): boolean;
- Xfunction bLocCur(cx, cy: integer; var lx, ly, sx, sy: integer): boolean;
- Xprocedure beep(sound: SoundType);
- Xprocedure dotStone(lx, ly: integer);
- Xprocedure showAllStones;
- Xprocedure printBoard(isDiagram: boolean);
- Xprocedure showCaptures;
- Xprocedure turnIs(who: sType);
- Xprocedure refreshBoard;
- Xprocedure putBString(x, y: integer; s: string);
- X
- Xprivate
- X
- Ximports raster from raster;
- Ximports io_unit from io_unit;
- Ximports io_others from io_others;
- Ximports memory from memory;
- Ximports fileSystem from fileSystem;
- Ximports perq_string from perq_string;
- Ximports csdx from csdx;
- Ximports goMgr from goMgr;
- Ximports goTree from goTree;
- Ximports goMenu from goMenu;
- Ximports system from system;
- Ximports go from go;
- X
- Xconst
- X sPicC = 15;
- X sPicS = 32;
- X hpPicS = 10;
- X hpPicC = 4;
- X patchS = 40;
- X patchC = 19;
- X picWW = 4;
- X htHeight = 4;
- X htWidth = 48;
- X gridWidth = 32;
- X pGridWidth = 34; { for printing }
- X xMargin = boardX + gridWidth;
- X yMargin = boardY + gridWidth;
- X pxMargin = pBoardX + pGridWidth;
- X pyMargin = pBoardY + pGridWidth;
- X gridBorder = gridWidth div 2;
- X pGridBorder = pGridWidth div 2;
- X gridXMargin = xMargin - gridBorder;
- X gridYMargin = yMargin - gridBorder;
- X pGridXMargin = pxMargin - pGridBorder;
- X pGridYMargin = pyMargin - pGridBorder;
- X htXMargin = xMargin - gridWidth;
- X htYMargin = yMargin - gridWidth;
- X phtXMargin = pxMargin - pGridWidth;
- X phtYMargin = pyMargin - pGridWidth;
- X boardHeight = 20 * gridWidth;
- X pBoardHeight = 20 * pGridWidth;
- X slopSize = 2;
- X lineWidth = 2;
- X extraXO = pxMargin; { 96 }
- X extraYO = 768;
- X pedgeBX = pxMargin; { 96 }
- X pedgeBY = pyMargin + (19 * pGridWidth); { 672 }
- X pedgeLX = pBoardX; { 64 }
- X pedgeLY = pBoardY + (19 * pGridWidth); { 640 }
- X edgeBX = xMargin; { 96 }
- X edgeBY = yMargin + (19 * GridWidth); { 672 }
- X edgeLX = BoardX; { 64 }
- X edgeLY = BoardY + (19 * GridWidth); { 640 }
- X rCmtY = pBoardX + pBoardHeight + 32;
- X lCmtY = rCmtY + 8 + charHeight;
- X tFntWidth = 6;
- X tFntHeight = 9;
- X maxSMark = 2;
- X
- Xtype
- X htArray = array[0..3] of array[0..47] of integer;
- X pHtArray = ^htArray;
- X
- X beepbuf = array[0..63] of integer;
- X pBeepBuf = ^BeepBuf;
- X
- Xvar
- X hcDot: pPicBuf;
- X htBuf: pHtArray;
- X patch: array[1..9] of pPicBuf;
- X StatPtr: IOStatPtr;
- X statRec: IOStatus;
- X sounds: array[atari..die3] of pBeepBuf;
- X stones: array[sType] of pPicBuf;
- X stoneCir: pPicBuf;
- X stoneMarks: array[0..maxSMark] of pPicBuf;
- X sysFont: fontPtr;
- X goBNumFont: fontPtr;
- X goSNumFont: fontPtr;
- X goTNumFont: fontPtr;
- X goSLetFont: fontPtr;
- X printing: boolean;
- X scrSavPtr: rasterPtr;
- X sNumBase, sNumStart: integer;
- X bigNums: boolean;
- X
- X{ merely beeps the given sound }
- Xprocedure beep(sound: SoundType);
- Xvar
- X zilch: Double;
- X rep, i: integer;
- X savY, savB, savG, savW, savS: boolean;
- Xbegin { beep }
- X if sound = error then
- X IOBeep
- X else
- X begin
- X savY := tabYellow;
- X savW := tabWhite;
- X savG := tabGreen;
- X savB := tabBlue;
- X savS := tabSwitch;
- X IOSetModeTablet(offTablet);
- X if sound = die then
- X rep := 128 * 3
- X else
- X rep := 128;
- X UnitIO(Speech, RECAST(sounds[sound],IOBufPtr), IOWriteHiVol, rep,
- X zilch, nil, StatPtr);
- X IOSetModeTablet(relTablet);
- X tabYellow := savY;
- X tabWhite := savW;
- X tabGreen := savG;
- X tabBlue := savB;
- X tabSwitch := savS;
- X end;
- Xend { beep };
- X
- Xprocedure showCaptures;
- Xvar
- X s: string;
- X
- X procedure dectos(val: integer);
- X var
- X numC, i: integer;
- X ts: string;
- X c: char;
- X begin { dectos }
- X if val = 0 then
- X s := '0'
- X else
- X begin
- X numC := 0;
- X adjust(ts, 20);
- X while val <> 0 do
- X begin
- X numC := numC + 1;
- X ts[numC] := chr(val mod 10 + ord('0'));
- X val := val div 10;
- X end;
- X adjust(s, numC);
- X for i := 1 to numC do
- X s[i] := ts[numC - i + 1];
- X end;
- X end { dectos };
- X
- Xbegin { showCaptures }
- X dectos(captures[black]);
- X SSetCursor(captNBX, captNY);
- X write(s:3);
- X dectos(captures[white]);
- X SSetCursor(captNWX, captNY);
- X write(s:3);
- Xend { showCaptures };
- X
- Xprocedure turnIs(who: sType);
- Xbegin { turnIs }
- X SSetCursor(turnX, turnY);
- X if who = white then
- X write('White to Play')
- X else
- X write('Black to Play');
- Xend { turnIs };
- X
- Xprocedure putBString(x, y: integer; s: string);
- Xvar
- X xp, yp, sw, i: integer;
- X fnt: fontPtr;
- Xbegin { putBString }
- X setFont(goSNumFont);
- X fnt := goSNumFont;
- X for i := 1 to length(s) do
- X if (s[i] >= '0') and
- X (s[i] <= '9') then
- X s[i] := chr(ord(s[i]) - #46 + #200);
- X xp := x * gridWidth + xMargin;
- X yp := y * gridWidth + yMargin;
- X sw := 0;
- X for i := 1 to length(s) do
- X sw := sw + fnt^.index[lAnd(ord(s[i]), #177)].width;
- X xp := xp - (sw div 2);
- X yp := yp + (fnt^.height div 2) + 1;
- X SChrFunc(0);
- X SSetCursor(xp, yp);
- X write(s:0);
- Xend { putBString };
- X
- Xprocedure putStone(cx, cy, mNum: integer; val: bVal);
- Xconst
- X widthPad = 2;
- X shPad = 3;
- X bhPad = 1;
- Xvar
- X x, y, org: integer;
- X ns: string;
- X sl, d, sw, n: integer;
- X cv: integer;
- X fnt: fontPtr;
- X heightPad: integer;
- Xbegin { putStone }
- X x := cx - sPicC;
- X y := cy - sPicC;
- X rasterop(RAndNot, sPicS, sPicS, x, y, SScreenW, SScreenP,
- X 0, 0, picWW, stones[black]);
- X rasterop(ROr, sPicS, sPicS, x, y, SScreenW, SScreenP,
- X 0, 0, picWW, stones[val]);
- X if numbEnabled and (mNum > 0) then
- X begin
- X n := mNum - sNumBase;
- X if n < 0 then
- X exit(putStone);
- X n := n + sNumStart;
- X if bigNums then
- X begin
- X fnt := goBNumFont;
- X heightPad := bhPad;
- X end
- X else
- X begin
- X fnt := goSNumFont;
- X heightPad := shPad;
- X end;
- X if val = black then
- X if bigNums then
- X begin
- X if n > 9 then
- X org := ord('`')
- X else
- X org := ord('j');
- X end
- X else
- X begin
- X if n > 99 then
- X org := #24
- X else
- X org := #0;
- X end
- X else if bigNums then
- X begin
- X if n > 9 then
- X org := ord('@')
- X else
- X org := ord('J');
- X end
- X else
- X begin
- X if n > 99 then
- X org := #12
- X else
- X org := #60;
- X end;
- X ns := ' ';
- X sl := 0;
- X sw := 0;
- X if n >= 100 then
- X d := 100
- X else if n >= 10 then
- X d := 10
- X else
- X d := 1;
- X while d > 0 do
- X begin
- X sl := sl + 1;
- X cv := (n div d) + org;
- X ns[sl] := chr(cv + #200);
- X sw := sw + fnt^.index[cv].width;
- X n := n mod d;
- X d := d div 10;
- X end;
- X adjust(ns, sl);
- X x := cx - (sw div 2) + widthPad;
- X y := cy + (fnt^.height div 2) + heightPad;
- X setFont(fnt);
- X SSetCursor(x, y);
- X SChrFunc(6);
- X write(ns);
- X setFont(sysFont);
- X SChrFunc(0);
- X end;
- Xend { putStone };
- X
- Xprocedure showStone(lx, ly: integer);
- Xvar
- X x, y: integer;
- Xbegin { showStone }
- X with board[lx, ly] do
- X begin
- X if printing then
- X if printLarge then
- X begin
- X x := lx * pGridWidth + pxMargin;
- X y := ly * pGridWidth + pyMargin;
- X end
- X else { small board }
- X begin
- X x := lx * gridWidth + xMargin;
- X y := ly * gridWidth + yMargin;
- X end
- X else { not printing }
- X begin
- X x := lx * gridWidth + xMargin + xOfs;
- X y := ly * gridWidth + yMargin + yOfs;
- X end;
- X putStone(x, y, mNum, val);
- X end;
- Xend { showStone };
- X
- Xprocedure showAllStones;
- Xvar
- X i, j: integer;
- Xbegin { showAllStones }
- X for j := 0 to maxPoint do
- X for i := 0 to maxPoint do
- X if board[i, j].val <> empty then
- X showStone(i, j);
- Xend { showAllStones };
- X
- Xprocedure dotStone(lx, ly: integer);
- Xvar
- X x, y: integer;
- Xbegin { dotStone }
- X with board[lx, ly] do
- X if val <> empty then
- X begin
- X x := lx * gridWidth + xMargin + xOfs;
- X y := ly * gridWidth + yMargin + yOfs;
- X rasterop(rNot, 2, 2, x, y, SScreenW, SScreenP,
- X x, y, SScreenW, SScreenP);
- X end;
- Xend { dotStone };
- X
- Xfunction bLocCur(cx, cy: integer; var lx, ly, sx, sy: integer): boolean;
- Xvar
- X xic, yic: integer;
- Xbegin { bLocCur }
- X bLocCur := false;
- X if printing and printLarge then
- X begin
- X cx := cx - pGridXMargin;
- X cy := cy - pGridYMargin;
- X end
- X else
- X begin
- X cx := cx - gridXMargin;
- X cy := cy - gridYMargin;
- X end;
- X if (cx >= 0) and (cy >= 0) then
- X begin
- X if printing and printLarge then
- X begin
- X lx := cx div pGridWidth;
- X ly := cy div pGridWidth;
- X xic := lx * pGridWidth + pGridBorder;
- X yic := ly * pGridWidth + pGridBorder;
- X end
- X else
- X begin
- X lx := cx div gridWidth;
- X ly := cy div gridWidth;
- X xic := lx * gridWidth + gridBorder;
- X yic := ly * gridWidth + gridBorder;
- X end;
- X if (lx <= maxPoint) and (ly <= maxPoint) then
- X begin
- X if cx < xic - slopSize then
- X cx := xic - slopSize
- X else if cx > xic + slopSize then
- X cx := xic + slopSize;
- X if cy < yic - slopSize then
- X cy := yic - slopSize
- X else if cy > yic + slopSize then
- X cy := yic + slopSize;
- X sx := cx - xic;
- X sy := cy - yic;
- X bLocCur := true;
- X end;
- X end;
- Xend { bLocCur };
- X
- Xprocedure showPass(which: sType);
- Xbegin { showPass }
- X SSetCursor(passX, passY);
- X if which = black then
- X write(' Black Passes ')
- X else
- X write(' White Passes ');
- X passShowing := true;
- Xend { showPass };
- X
- Xprocedure remPass;
- Xbegin { remPass }
- X SSetCursor(passX, passY);
- X write(' ');
- X passShowing := false;
- Xend { remPass };
- X
- Xfunction passLocCur(cx, cy: integer): boolean;
- Xbegin { passLocCur }
- X passLocCur := (cx >= passX) and (cx < (passX + passW)) and
- X (cy <= passY) and (cy > (passY - passH));
- Xend { passLocCur };
- X
- Xprocedure showAlt(lx, ly: integer; sv: sType);
- Xbegin { showAlt }
- X with board[lx, ly] do
- X begin
- X lx := lx * gridWidth + xMargin - sPicC;
- X ly := ly * gridWidth + yMargin - sPicC;
- X rasterop(ROr, sPicS, sPicS, lx, ly, SScreenW, SScreenP,
- X 0, 0, picWW, stoneCir);
- X end;
- Xend { showAlt };
- X
- Xprocedure placeStone(which: sType; lx, ly, ofx, ofy, moveNum: integer);
- Xbegin { placeStone }
- X if passShowing then
- X remPass;
- X with board[lx, ly] do
- X begin
- X val := which;
- X xOfs := ofx;
- X yOfs := ofy;
- X mNum := moveNum;
- X showStone(lx, ly);
- X end;
- Xend { placeStone };
- X
- Xprocedure placeAlt(which: sType; lx, ly, ofx, ofy: integer);
- Xbegin { placeAlt }
- X with board[lx, ly] do
- X begin
- X val := alternate;
- X xOfs := 0;
- X yOfs := 0;
- X mNum := -1;
- X showAlt(lx, ly, which);
- X end;
- Xend { placeAlt };
- X
- Xprocedure remStone(lx, ly: integer);
- Xvar
- X x, y, i, j: integer;
- Xbegin { remStone }
- X with board[lx, ly] do
- X if val <> empty then
- X begin
- X val := empty;
- X if ly = 0 then
- X i := 1
- X else if ly = maxPoint then
- X i := 7
- X else i := 4;
- X if lx = maxPoint then
- X i := i + 2
- X else if lx > 0 then
- X i := i + 1;
- X if printing and printLarge then
- X begin
- X x := (lx * pGridWidth) - patchC + pxMargin;
- X y := (ly * pGridWidth) - patchC + pyMargin;
- X end
- X else
- X begin
- X x := (lx * gridWidth) - patchC + xMargin;
- X y := (ly * gridWidth) - patchC + yMargin;
- X end;
- X rasterop(RRpl, patchS, patchS, x, y, SScreenW, SScreenP,
- X 0, 0, picWW, patch[i]);
- X if ((lx = 3) and (ly = 3)) or
- X ((lx = 9) and (ly = 3)) or
- X ((lx = 15) and (ly = 3)) or
- X ((lx = 3) and (ly = 9)) or
- X ((lx = 9) and (ly = 9)) or
- X ((lx = 15) and (ly = 9)) or
- X ((lx = 3) and (ly = 15)) or
- X ((lx = 9) and (ly = 15)) or
- X ((lx = 15) and (ly = 15)) then
- X if printing and printLarge then
- X rasterop(ROr, hpPicS, hpPicS,
- X pxMargin + (pGridWidth * lx) - hpPicC,
- X pyMargin + (pGridWidth * ly) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot)
- X else
- X rasterop(ROr, hpPicS, hpPicS,
- X xMargin + (gridWidth * lx) - hpPicC,
- X yMargin + (gridWidth * ly) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X for i := lx - 1 to lx + 1 do
- X for j := ly - 1 to ly + 1 do
- X if (i >= 0) and (i <= maxPoint) and
- X (j >= 0) and (j <= maxPoint) then
- X if (board[i, j].val = black) or
- X (board[i, j].val = white) then
- X begin
- X showStone(i, j);
- X if (i = dotSX) and (j = dotSY) then
- X dotStone(i, j);
- X end;
- X end;
- Xend { remStone };
- X
- Xprocedure addHCStones(num: integer);
- Xbegin { addHCStones }
- X case num of
- X 2:
- X begin
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X end;
- X 3:
- X begin
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X 4:
- X begin
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 3, 3, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X 5:
- X begin
- X placeStone(black, 3, 3, 0, 0, 0);
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 9, 9, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X 6:
- X begin
- X placeStone(black, 3, 3, 0, 0, 0);
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 3, 9, 0, 0, 0);
- X placeStone(black, 15, 9, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X 7:
- X begin
- X placeStone(black, 3, 3, 0, 0, 0);
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 3, 9, 0, 0, 0);
- X placeStone(black, 9, 9, 0, 0, 0);
- X placeStone(black, 15, 9, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X 8:
- X begin
- X placeStone(black, 3, 3, 0, 0, 0);
- X placeStone(black, 3, 9, 0, 0, 0);
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 9, 3, 0, 0, 0);
- X placeStone(black, 9, 15, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 15, 9, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X 9:
- X begin
- X placeStone(black, 3, 3, 0, 0, 0);
- X placeStone(black, 3, 9, 0, 0, 0);
- X placeStone(black, 3, 15, 0, 0, 0);
- X placeStone(black, 9, 3, 0, 0, 0);
- X placeStone(black, 9, 9, 0, 0, 0);
- X placeStone(black, 9, 15, 0, 0, 0);
- X placeStone(black, 15, 3, 0, 0, 0);
- X placeStone(black, 15, 9, 0, 0, 0);
- X placeStone(black, 15, 15, 0, 0, 0);
- X end;
- X end;
- Xend { addHCStones };
- X
- Xprocedure drawBoard;
- Xvar
- X i, j, c, lWidth, x, y, w: integer;
- X xMarg, yMarg, gWid, eBX, eBY, eLX, eLY: integer;
- Xbegin { drawBoard }
- X if printing then
- X begin
- X lWidth := 1;
- X if printLarge then
- X begin
- X xMarg := pxMargin;
- X yMarg := pyMargin;
- X gWid := pGridWidth;
- X eBX := pedgeBX;
- X eBY := pedgeBY;
- X eLX := pedgeLX;
- X eLY := pedgeLY;
- X end
- X else
- X begin
- X xMarg := xMargin;
- X yMarg := yMargin;
- X gWid := gridWidth;
- X eBX := edgeBX;
- X eBY := edgeBY;
- X eLX := edgeLX;
- X eLY := edgeLY;
- X end
- X end
- X else
- X begin
- X lWidth := lineWidth;
- X xMarg := xMargin;
- X yMarg := yMargin;
- X gWid := gridWidth;
- X end;
- X if not printing then
- X for i := (htYMargin div htHeight) to
- X ((htYMargin + boardHeight) div htHeight) - 1 do
- X rasterop(RRpl, bWinW - (htXMargin * 2), htHeight,
- X htXMargin, i * htHeight, SScreenW, SScreenP,
- X htXMargin, 0, htWidth, htBuf)
- X else
- X rasterop(rAndNot, bWinW - (phtXMargin * 2), (bWinY + bWinH) - phtYMargin,
- X phtXMargin, phtYMargin, SScreenW, SScreenP,
- X phtXMargin, phtYMargin, SScreenW, SScreenP);
- X for i := 1 to maxPoint - 1 do
- X rasterop(ROrNot, (maxPoint * gWid) + lWidth, lWidth,
- X xMarg, yMarg + (i * gWid), SScreenW, SScreenP,
- X xMarg, yMarg + (i * gWid), SScreenW, SScreenP);
- X for i := 1 to maxPoint - 1 do
- X rasterop(ROrNot, lWidth, (maxPoint * gWid) + lWidth,
- X xMarg + (i * gWid), yMarg, SScreenW, SScreenP,
- X xMarg + (i * gWid), yMarg, SScreenW, SScreenP);
- X rasterop(ROrNot, (maxPoint * gWid) + lineWidth, lineWidth,
- X xMarg, yMarg, SScreenW, SScreenP,
- X xMarg, yMarg, SScreenW, SScreenP);
- X rasterop(ROrNot, (maxPoint * gWid) + lineWidth, lineWidth,
- X xMarg, yMarg + (maxPoint * gWid), SScreenW, SScreenP,
- X xMarg, yMarg + (maxPoint * gWid), SScreenW, SScreenP);
- X rasterop(ROrNot, lineWidth, (maxPoint * gWid) + lineWidth,
- X xMarg, yMarg, SScreenW, SScreenP,
- X xMarg, yMarg, SScreenW, SScreenP);
- X rasterop(ROrNot, lineWidth, (maxPoint * gWid) + lineWidth,
- X xMarg + (maxPoint * gWid), yMarg, SScreenW, SScreenP,
- X xMarg + (maxPoint * gWid), yMarg, SScreenW, SScreenP);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 3) - hpPicC,
- X yMarg + (gWid * 3) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 9) - hpPicC,
- X yMarg + (gWid * 3) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 15) - hpPicC,
- X yMarg + (gWid * 3) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 3) - hpPicC,
- X yMarg + (gWid * 9) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 9) - hpPicC,
- X yMarg + (gWid * 9) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 15) - hpPicC,
- X yMarg + (gWid * 9) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 3) - hpPicC,
- X yMarg + (gWid * 15) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 9) - hpPicC,
- X yMarg + (gWid * 15) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X rasterop(ROr, hpPicS, hpPicS,
- X xMarg + (gWid * 15) - hpPicC,
- X yMarg + (gWid * 15) - hpPicC,
- X SScreenW, SScreenP,
- X 0, 0, picWW, hcDot);
- X if not printing then
- X begin
- X SSetCursor(captBX, captY);
- X write('Black Captures');
- X SSetCursor(captWX, captY);
- X write('White Captures');
- X end
- X else
- X begin
- X for i := 1 to maxPoint + 1 do
- X begin
- X if i > 9 then
- X w := charWidth * 2
- X else
- X w := charWidth;
- X x := ((i - 1) * gWid) + eBX - (w div 2);
- X y := eBY + charHeight;
- X SSetCursor(x, y);
- X write(i:0);
- X end;
- X for i := 0 to maxPoint do
- X begin
- X x := eLX - charWidth;
- X y := eLY - ((maxPoint - i) * gWid) + (charHeight div 2);
- X c := i + ord('A');
- X if c >= ord('I') then
- X c := c + 1;
- X SSetCursor(x, y);
- X SPutChr(chr(c));
- X end;
- X end;
- Xend { drawBoard };
- X
- Xprocedure clearBoard;
- Xvar
- X i, j, xMarg, yMarg, gWid: integer;
- Xbegin { clearBoard }
- X drawBoard;
- X if printing and printLarge then
- X begin
- X xMarg := pxMargin;
- X yMarg := pyMargin;
- X gWid := pGridWidth;
- X end
- X else
- X begin
- X xMarg := xMargin;
- X yMarg := yMargin;
- X gWid := gridWidth;
- X end;
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[1],
- X xMarg + (0 * gWid) - patchC,
- X yMarg + (0 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[2],
- X xMarg + (6 * gWid) - patchC,
- X yMarg + (0 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[3],
- X xMarg + (18 * gWid) - patchC,
- X yMarg + (0 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[4],
- X xMarg + (0 * gWid) - patchC,
- X yMarg + (6 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[5],
- X xMarg + (6 * gWid) - patchC,
- X yMarg + (6 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[6],
- X xMarg + (18 * gWid) - patchC,
- X yMarg + (6 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[7],
- X xMarg + (0 * gWid) - patchC,
- X yMarg + (18 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[8],
- X xMarg + (6 * gWid) - patchC,
- X yMarg + (18 * gWid) - patchC,
- X SScreenW, SScreenP);
- X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[9],
- X xMarg + (18 * gWid) - patchC,
- X yMarg + (18 * gWid) - patchC,
- X SScreenW, SScreenP);
- X for i := 0 to maxPoint do
- X for j := 0 to maxPoint do
- X board[i][j].val := empty;
- X if not printing then
- X remPass;
- Xend { clearBoard };
- X
- Xprocedure showPlayHistory(isDiagram: boolean);
- Xvar
- X curRow, curCol, bx, by, bLim, curNum: integer;
- X cm, scm, tm: pMRec;
- X c: char;
- X needWipe, lastCapt: boolean;
- X
- X procedure getMarks;
- X var
- X bx, by, lbx, lby, gx, gy, sMark, x, y, w: integer;
- X curC: char;
- X done: boolean;
- X begin { getMarks }
- X lbx := -1;
- X lby := -1;
- X curC := 'a';
- X sMark := 0;
- X prompt('Point at locations to place marks - press off board to stop');
- X while tabSwitch do;
- X done := false;
- X setFont(goSLetFont);
- X sChrFunc(rOr);
- X repeat
- X while not tabSwitch do;
- X if bLocCur(tabRelX, tabRelY, bx, by, gx, gy) then
- X begin
- X if printLarge then
- X begin
- X x := bx * pGridWidth + pxMargin;
- X y := by * pGridWidth + pyMargin;
- X end
- X else
- X begin
- X x := bx * GridWidth + xMargin;
- X y := by * GridWidth + yMargin;
- X end;
- X if board[bx, by].val = empty then
- X begin
- X rasterop(rXor, 20, 30, x - 10, y - 15, SScreenW, SScreenP,
- X x - 10, y - 15, SScreenW, SScreenP);
- X w := goSLetFont^.index[ord(curC)].width - 2;
- X SSetCursor(x - (w div 2), y + 7);
- X write(curC);
- X curC := chr(ord(curC) + 1);
- X end
- X else
- X begin
- X x := x - sPicC;
- X y := y - sPicC;
- X if (bx = lbx) and (by = lby) then
- X begin
- X if sMark <= maxSMark then
- X begin
- X rasterop(RXor, sPicS, sPicS, x, y, SScreenW, SScreenP,
- X 0, 0, picWW, stoneMarks[sMark]);
- X sMark := sMark + 1;
- X end
- X else
- X sMark := 0;
- X end
- X else
- X sMark := 0;
- X if sMark <= maxSMark then
- X rasterop(RXor, sPicS, sPicS, x, y, SScreenW, SScreenP,
- X 0, 0, picWW, stoneMarks[sMark]);
- X end;
- X lbx := bx;
- X lby := by;
- X end
- X else
- X done := true;
- X while tabSwitch do;
- X until done;
- X sChrFunc(rRpl);
- X setFont(sysFont);
- X prompt('');
- X end { getMarks };
- X
- Xbegin { showPlayHistory }
- X if not isDiagram then
- X begin
- X bLim := 99;
- X sNumBase := 0;
- X sNumStart := 0;
- X end
- X else
- X bLim := 1000;
- X curNum := 0;
- X needWipe := true;
- X wipeTreeMarks;
- X cm := curMove;
- X while cm <> treeRoot do
- X begin
- X cm^.mark := true;
- X cm := cm^.blink;
- X end;
- X repeat
- X if needWipe then
- X begin
- X rasterop(rAndNot, 768, 1024 - extraYO,
- X 0, extraYO, SScreenW, SScreenP,
- X 0, extraYO, SScreenW, SScreenP);
- X curRow := 0;
- X curCol := 0;
- X showAllStones;
- X needWipe := false;
- X end;
- X cm := cm^.flink;
- X while not cm^.mark do
- X cm := cm^.slink;
- X with cm^ do
- X case id of
- X hcPlay:
- X begin
- X addHCStones(hcNum);
- X curNum := 1;
- X end;
- X move:
- X begin
- X if board[mx, my].val <> empty then
- X begin
- X bx := curCol * (20 * charWidth) + extraXO;
- X by := curRow * charHeight * 2 + extraYO + charHeight;
- X SSetCursor(bx, by);
- X if who = black then
- X write('Black ')
- X else
- X write('White ');
- X write((moveN - sNumBase):0, ' at ');
- X c := chr(my + ord('A'));
- X if c >= 'I' then
- X c := chr(ord(c) + 1);
- X write(c, '-', (mx + 1):0);
- X curRow := curRow + 1;
- X if (curRow * charHeight * 2 + extraYO + charHeight) > 1000 then
- X begin
- X curRow := 0;
- X curCol := curCol + 1;
- X end;
- X end
- X else
- X placeStone(who, mx, my, 0, 0, moveN);
- X curNum := moveN;
- X lastCapt := false;
- X repeat
- X if cm^.flink = nil then
- X lastCapt := true
- X else if cm^.flink^.id = remove then
- X begin
- X cm := cm^.flink;
- X if curNum < sNumBase then
- X remStone(cm^.mx, cm^.my);
- X end
- X else
- X lastCapt := true;
- X until lastCapt;
- X end;
- X pass:
- X begin
- X if not isDiagram then
- X begin
- X bx := curCol * (20 * charWidth) + extraXO;
- X by := curRow * charHeight * 2 + extraYO + charHeight;
- X SSetCursor(bx, by);
- X if who = black then
- X write('Black ')
- X else
- X write('White ');
- X write((moveN - sNumBase):0, ' - Pass');
- X curRow := curRow + 1;
- X if (curRow * charHeight * 2 + extraYO + charHeight) > 1000 then
- X begin
- X curRow := 0;
- X curCol := curCol + 1;
- X end;
- X end;
- X curNum := moveN;
- X end;
- X end { case };
- X if (curNum = bLim) or
- X (cm = curMove) then
- X begin
- X if isDiagram then
- X getMarks;
- X csdx;
- X if cm <> curMove then
- X begin
- X sNumBase := bLim + 1;
- X bLim := bLim + 100;
- X needWipe := true;
- X clearBoard;
- X scm := curMove;
- X curMove := treeRoot;
- X switchBranch(cm);
- X curMove := scm;
- X wipeTreeMarks;
- X tm := curMove;
- X while tm <> treeRoot do
- X begin
- X tm^.mark := true;
- X tm := tm^.blink;
- X end;
- X end;
- X end;
- X until cm = curMove;
- X sNumBase := 0;
- X sNumStart := 0;
- Xend { showPlayHistory };
- X
- Xprocedure printBoard(isDiagram: boolean);
- Xlabel
- X 1;
- Xvar
- X sseg: integer;
- X neWas: boolean;
- X cmSave: pMRec;
- X
- X procedure showFName;
- X var
- X fnX, fnY: integer;
- X fs: string;
- X begin { showFName }
- X getFNameString(fs);
- X if fs <> '' then
- X begin
- X fnY := charHeight + 8;
- X fnX := 384 - (charWidth * length(fs) div 2);
- X SSetCursor(fnX, fnY);
- X write(fs);
- X end;
- X end { showFName };
- X
- X procedure showComments(isDiagram: boolean);
- X var
- X cx: integer;
- X cs: string;
- X begin { showComments }
- X if not isDiagram then
- X if getComment(treeRoot, cs) then
- X begin
- X cx := 384 - (charWidth * length(cs) div 2);
- X SSetCursor(cx, rCmtY);
- X write(cs);
- X end;
- X if getComment(curMove, cs) then
- X begin
- X cx := 384 - (charWidth * length(cs) div 2);
- X if isDiagram then
- X SSetCursor(cx, charHeight + 8)
- X else
- X SSetCursor(cx, lCmtY);
- X write(cs);
- X end;
- X end { showComments };
- X
- X handler ctlC;
- X begin { ctlC }
- X IOKeyClear;
- X resetInput;
- X write(''); {control-G}
- X prompt('');
- X goto 1;
- X end { ctlC };
- X
- X function readNum(pmpt: string): integer;
- X label
- X 2;
- X var
- X n: integer;
- X
- X handler notNumber(fn: pathName);
- X begin { notNumber }
- X write(''); {control-G}
- X prompt('Bad Number - try again: ');
- X goto 2;
- X end { notNumber };
- X
- X handler pastEOF(fn: pathName);
- X begin { pastEOF }
- X write(''); {control-G}
- X goto 1;
- X end { pastEOF };
- X
- X begin { readNum }
- X prompt('');
- X 2:
- X resetInput;
- X write(pmpt);
- X readln(n);
- X readNum := n;
- X end { readNum };
- X
- Xbegin { printBoard }
- X if curMove = treeRoot then
- X begin
- X write(''); {control-G}
- X exit(printBoard);
- X end;
- X cmSave := curMove;
- X if scrSavPtr = nil then
- X begin
- X createSegment(sseg, 192, 1, 192);
- X scrSavPtr := makePtr(sseg, 0, rasterPtr);
- X end;
- X rasterop(rRpl, 768, 1024, 0, 0, SScreenW, scrSavPtr,
- X 0, 0, SScreenW, SScreenP);
- X rasterop(rAndNot, 768, 1024, 0, 0, SScreenW, SScreenP,
- X 0, 0, SScreenW, SScreenP);
- X printing := true;
- X neWas := numbEnabled;
- X numbEnabled := true;
- X sNumBase := 0;
- X sNumStart := 0;
- X drawBoard;
- X bigNums := false;
- X showAllStones;
- X if not isDiagram then
- X begin
- X showComments(false);
- X showFName;
- X csdx;
- X end
- X else
- X begin
- X sNumBase := readNum('Start Numbering at which stone? ');
- X sNumStart := readNum('First Number is? ');
- X prompt('');
- X end;
- X clearBoard;
- X bigNums := true;
- X if isDiagram then
- X showComments(true);
- X showPlayHistory(isDiagram);
- X1:
- X rasterop(rRpl, 768, 1024, 0, 0, SScreenW, SScreenP,
- X 0, 0, SScreenW, scrSavPtr);
- X printing := false;
- X numbEnabled := neWas;
- X bigNums := false;
- X sNumBase := 0;
- X sNumStart := 0;
- X clearBoard;
- X curMove := treeRoot;
- X captures[black] := 0;
- X captures[white] := 0;
- X switchBranch(cmSave);
- X curMove := cmSave;
- Xend { printBoard };
- X
- Xprocedure refreshBoard;
- Xbegin { refreshBoard }
- X drawBoard;
- X showAllStones;
- X dotSX := -1;
- X dotLast;
- Xend { refreshBoard };
- X
- X{ initializes this module }
- Xprocedure initGoBoard;
- X
- X procedure beepInit;
- X const
- X size = (WordSize(beepBuf) * 7 + 255) div 256;
- X var
- X d: SoundType;
- X i,j: integer;
- X beepSeg: integer;
- X begin { beepInit }
- X createSegment(beepSeg, size, 1, size);
- X new(0,4,StatPtr);
- X for d := atari to die3 do
- X new(beepSeg, 4, sounds[d]);
- X for i := 0 to 63 do
- X begin
- X sounds[atari]^[i] := 511;
- X case i mod 3 of
- X 0: sounds[koV]^[i] := -5;
- X 1: sounds[koV]^[i] := 34;
- X 2: sounds[koV]^[i] := 0;
- X end;
- X case i mod 4 of
- X 0: sounds[s3]^[i] := 1023;
- X 1: sounds[s3]^[i] := 0;
- X 2: sounds[s3]^[i] := -1;
- X 3: sounds[s3]^[i] := -1023;
- X end;
- X case i mod 5 of
- X 0: sounds[s4]^[i] := 43;
- X 1: sounds[s4]^[i] := 765;
- X 2: sounds[s4]^[i] := -432;
- X 3: sounds[s4]^[i] := -6;
- X 4: sounds[s4]^[i] := 345;
- X end;
- X end;
- X for i := 0 to 1 do
- X for j := 0 to 15 do
- X begin
- X sounds[die]^[i*32+j] := -1;
- X sounds[die]^[i*32+16+j] := 0;
- X end;
- X for i := 0 to 63 do
- X begin
- X sounds[die2]^[i] := sounds[die]^[i];
- X sounds[die3]^[i] := sounds[die]^[i];
- X end;
- X end { beepInit };
- X
- X procedure definePats;
- X var
- X i, j, blks, gbg: integer;
- X fid: fileID;
- X begin { definePats }
- X fid := FSLookup('go.animate', blks, gbg);
- X if fid = 0 then
- X begin
- X writeln('GO.ANIMATE not found');
- X raise gbFatal;
- X end
- X else if blks < 8 then
- X begin
- X writeln('GO.ANIMATE too short');
- X raise gbFatal;
- X end;
- X new(0, 4, stones[black]);
- X FSBlkRead(fid, 0, recast(stones[black], pDirBlk));
- X new(0, 4, stones[white]);
- X FSBlkRead(fid, 1, recast(stones[white], pDirBlk));
- X new(0, 4, hcDot);
- X FSBlkRead(fid, 2, recast(hcDot, pDirBlk));
- X new(0, 4, selCursor);
- X FSBlkRead(fid, 3, recast(selCursor, pDirBlk));
- X new(0, 4, stoneCir);
- X FSBlkRead(fid, 4, recast(stoneCir, pDirBlk));
- X new(0, 4, stoneMarks[0]);
- X FSBlkRead(fid, 5, recast(stoneMarks[0], pDirBlk));
- X new(0, 4, stoneMarks[1]);
- X FSBlkRead(fid, 6, recast(stoneMarks[1], pDirBlk));
- X new(0, 4, stoneMarks[2]);
- X FSBlkRead(fid, 7, recast(stoneMarks[2], pDirBlk));
- X new(0, 4, htBuf);
- X for i := 0 to 47 do
- X htBuf^[0, i] := #125252;
- X for i := 0 to 47 do
- X htBuf^[1, i] := 0;
- X for i := 0 to 47 do
- X htBuf^[2, i] := #125252; { #52525 }
- X for i := 0 to 47 do
- X htBuf^[3, i] := 0;
- X for i := 1 to 9 do
- X new(0, 4, patch[i]);
- X end { definePats };
- X
- X procedure setupFont;
- X var
- X bblks, sblks, tBlks, lBlks, bits, fontseg, i: integer;
- X bFID, sFID, tFID, lFID: fileID;
- X bp: pDirBlk;
- X begin { setupFont }
- X sysFont := getFont;
- X bFID := FSLookup('goBNum.kst', bblks, bits);
- X if bFID = 0 then
- X begin
- X writeln('goBNum.KST not found');
- X raise gbFatal;
- X end;
- X sFID := FSLookup('goSNum.kst', sblks, bits);
- X if sFID = 0 then
- X begin
- X writeln('goSNum.KST not found');
- X raise gbFatal;
- X end;
- X tFID := FSLookup('goTNum.kst', tblks, bits);
- X if sFID = 0 then
- X begin
- X writeln('goTNum.KST not found');
- X raise gbFatal;
- X end;
- X lFID := FSLookup('goSLets.kst', lBlks, bits);
- X if lFID = 0 then
- X begin
- X writeln('goSLets.KST not found');
- X raise gbFatal;
- X end;
- X createSegment(fontseg, bblks + sblks + tBlks + lBlks, 1,
- X bblks + sblks + tBlks + lBlks);
- X for i := 0 to bblks - 1 do
- X begin
- X bp := makePtr(fontSeg, i * 256, pDirBlk);
- X FSBlkRead(bFID, i, bp);
- X end;
- X goBNumFont := makePtr(fontseg, 0, fontPtr);
- X for i := 0 to sblks - 1 do
- X begin
- X bp := makePtr(fontSeg, (i + bblks) * 256, pDirBlk);
- X FSBlkRead(sFID, i, bp);
- X end;
- X goSNumFont := makePtr(fontseg, bblks * 256, fontPtr);
- X for i := 0 to tblks - 1 do
- X begin
- X bp := makePtr(fontSeg, (i + bblks + sBlks) * 256, pDirBlk);
- X FSBlkRead(tFID, i, bp);
- X end;
- X goTNumFont := makePtr(fontseg, (bblks + sBlks) * 256, fontPtr);
- X for i := 0 to lBlks - 1 do
- X begin
- X bp := makePtr(fontSeg, (i + bblks + sBlks + tBlks) * 256, pDirBlk);
- X FSBlkRead(lFID, i, bp);
- X end;
- X goSLetFont := makePtr(fontseg, (bblks + sBlks + tBlks) * 256, fontPtr);
- X end { setupFont };
- X
- Xbegin { initGoBoard }
- X printing := false;
- X beepInit;
- X definePats;
- X setupFont;
- X scrSavPtr := nil;
- X sNumBase := 0;
- X sNumStart := 0;
- X bigNums := false;
- Xend. { initGoBoard }
- X
- END_OF_goBoard.pas
- echo shar: 4 control characters may be missing from \"goBoard.pas\"
- if test 38053 -ne `wc -c <goBoard.pas`; then
- echo shar: \"goBoard.pas\" unpacked with wrong size!
- fi
- # end of overwriting check
- fi
- if test -f goTree.pas -a "${1}" != "-c" ; then
- echo shar: Will not over-write existing file \"goTree.pas\"
- else
- echo shar: Extracting \"goTree.pas\" \(19784 characters\)
- sed "s/^X//" >goTree.pas <<'END_OF_goTree.pas'
- X{---------------------------------------------------------------}
- X{ GoTree.Pas }
- X{ }
- X{ Go Game Tree Manager }
- X{ Copyright (c) 1982 by Three Rivers Computer Corp. }
- X{ }
- X{ Written: June 3, 1982 by Stoney Ballard }
- X{ Edit History: }
- X{ June 3, 1982 Started }
- X{ June 4, 1982 Add dead group removal }
- X{ June 10, 1982 Use new go file manager }
- X{ Nov 9, 1982 Extracted from GO.PAS }
- X{ Nov 15, 1982 Added tag and comment deletion }
- X{ Jan 5, 1983 Increased segment max sizes }
- X{ Jan 7, 1983 Changed File Format to have global comment }
- X{---------------------------------------------------------------}
- X
- Xmodule goTree;
- X
- Xexports
- X
- Ximports goCom from goCom;
- Ximports getTimeStamp from getTimeStamp;
- X
- Xtype
- X pMRec = ^moveRec;
- X
- X tagStr = string[maxTagLen];
- X tagPtr = ^tagRec;
- X tagRec = record
- X mPtr: pMRec;
- X nextTag: tagPtr;
- X sTag: tagStr;
- X end;
- X
- X mType = (header, move, remove, hcPlay, pass);
- X moveRec = packed record
- X mark: boolean;
- X flink: pMRec;
- X case id: mType of
- X header:
- X (lastMove: pMRec;
- X freePool: pMRec;
- X lastTag: tagPtr;
- X nextMRec: integer;
- X nextMBlock: integer;
- X nextTRec: integer;
- X nextTBlock: integer;
- X nextCIdx: integer;
- X nextCBlock: integer;
- X freeTags: tagPtr);
- X hcPlay, move, remove, pass:
- X (blink: pMRec;
- X slink: pMRec;
- X tag: tagPtr;
- X who: sType;
- X moveN: integer;
- X cmtBase: integer;
- X cmtLen: integer;
- X case {id:} mType of
- X hcPlay:
- X (hcNum: integer);
- X move, remove:
- X (mx: integer;
- X my: integer;
- X ox: integer;
- X oy: integer;
- X kx: integer;
- X ky: integer) )
- X end;
- X
- X baseBlock = packed record
- X case boolean of
- X false:
- X (padding: array[1..512] of char);
- X true:
- X (randBool: boolean;
- X oldTest: pointer;
- X fileVersion: integer;
- X created: timeStamp;
- X rootComment: string[127])
- X end;
- X
- X pBaseBlock = ^baseBlock;
- X
- Xvar
- X treeRoot: pMRec;
- X stepTag: tagPtr;
- X hdrBlock: pBaseBlock;
- X
- Xexception goFNF;
- Xexception badGoWrite;
- Xexception badFileVersion;
- X
- Xprocedure initGoTree;
- Xprocedure makeGoTree;
- Xprocedure readTree(nam: string);
- Xprocedure writeTree(nam: string; lm: pMRec);
- Xfunction newMove(cm: pMRec): pMRec;
- Xfunction delBranch(pm: pMRec): pMRec;
- Xfunction hasAlts(pm: pMRec): boolean;
- Xfunction isBranch(pm: pMRec): boolean;
- Xfunction hasBranch(pm: pMRec): boolean;
- Xfunction mergeMove(cm: pMRec): pMRec;
- Xprocedure tagMove(cm: pMRec; ts: tagStr);
- Xfunction tagExists(ts: tagStr): boolean;
- Xprocedure commentMove(cm: pMRec; cs: string);
- Xfunction getComment(cm: pMRec; var cs: string): boolean;
- Xfunction getTag(cm: pMRec; var ts: string): boolean;
- Xprocedure delTag(tp: tagPtr);
- Xprocedure getFNameString(var fs: string);
- X
- Xprivate
- X
- Ximports fileSystem from fileSystem;
- Ximports memory from memory;
- Ximports perq_string from perq_string;
- Ximports clock from clock;
- X
- Xconst
- X curFileVersion = 1;
- X minTreeSize = 20;
- X minTagSize = 4;
- X minCmtSize = 4;
- X maxTreeSize = 255;
- X maxTagSize = 64;
- X maxCmtSize = 128;
- X treeSegInc = 8;
- X tagSegInc = 4;
- X cmtSegInc = 4;
- X
- Xtype
- X caType = packed array[0..1] of char;
- X pCmtArray = ^caType;
- X
- Xvar
- X mFID: FileID;
- X treeSeg, tagSeg, cmtSeg: integer;
- X trSegSize, tagSegSize, cmtSegSize: integer;
- X cmtArray: pCmtArray;
- X cmtCmpArray: array[1..1024] of pMRec;
- X
- Xprocedure getFNameString(var fs: string);
- Xvar
- X ts: string;
- Xbegin { getFNameString }
- X fs := gameFName;
- X if fs <> '' then
- X begin
- X stampToString(hdrBlock^.created, ts);
- X fs := concat(fs, ' ');
- X fs := concat(fs, ts);
- X end;
- Xend { getFNameString };
- X
- Xfunction isBranch(pm: pMRec): boolean;
- Xbegin { isBranch }
- X repeat
- X if pm = treeRoot then
- X begin
- X isBranch := false;
- X exit(isBranch);
- X end;
- X pm := pm^.blink;
- X until pm^.flink^.slink <> nil;
- X isBranch := true;
- Xend { isBranch };
- X
- Xfunction hasBranch(pm: pMRec): boolean;
- Xbegin { hasBranch }
- X while pm^.flink <> nil do
- X if pm^.flink^.slink <> nil then
- X begin
- X hasBranch := true;
- X exit(hasBranch);
- X end
- X else
- X pm := pm^.flink;
- X hasBranch := false;
- Xend { hasBranch };
- X
- Xprocedure initSegs(trSize, tagSize, cmtSize: integer);
- Xbegin { initSegs }
- X if treeSeg <> -1 then
- X begin
- X changeSize(treeSeg, trSize);
- X changeSize(tagSeg, tagSize);
- X changeSize(cmtSeg, cmtSize);
- X end
- X else
- X begin
- X createSegment(treeSeg, trSize, treeSegInc, maxTreeSize);
- X createSegment(tagSeg, tagSize, tagSegInc, maxTagSize);
- X createSegment(cmtSeg, cmtSize, cmtSegInc, maxCmtSize);
- X end;
- X trSegSize := trSize;
- X tagSegSize := tagSize;
- X cmtSegSize := cmtSize;
- Xend { initSegs };
- X
- Xprocedure initHdrBlock;
- Xbegin { initHdrBlock }
- X with hdrBlock^ do
- X begin
- X oldTest := nil;
- X fileVersion := curFileVersion;
- X getTStamp(created);
- X rootComment := '';
- X end;
- Xend { initHdrBlock };
- X
- Xprocedure makeGoTree;
- Xbegin { makeGoTree }
- X initSegs(minTreeSize, minTagSize, minCmtSize);
- X initHdrBlock;
- X treeRoot := makePtr(treeSeg, 0, pMRec);
- X with treeRoot^ do
- X begin
- X id := header;
- X freePool := nil;
- X flink := nil;
- X lastTag := nil;
- X nextMRec := wordSize(moveRec);
- X nextMBlock := minTreeSize * 256;
- X nextTRec := 0;
- X nextTBlock := minTagSize * 256;
- X nextCIdx := 0;
- X nextCBlock := minCmtSize * 512;
- X freeTags := nil;
- X end;
- X cmtArray := makePtr(cmtSeg, 0, pCmtArray);
- X stepTag := nil;
- Xend { makeGoTree };
- X
- Xprocedure readTree(nam: string);
- Xtype
- X ptrHack = record
- X case integer of
- X 0: (p: pMRec);
- X 1: (pt: tagPtr);
- X 2: (po: integer;
- X ps: integer);
- X end;
- Xvar
- X size, gbg, i, b: integer;
- X pd: pDirBlk;
- X ph: ptrHack;
- X pm: pMRec;
- X tm: tagPtr;
- X mBlks, tBlks, cBlks: integer;
- Xbegin { readTree }
- X initSegs(minTreeSize, minTagSize, minCmtSize);
- X mFID := FSLookup(nam, size, gbg);
- X if mFID = 0 then
- X raise goFNF;
- X FSBlkRead(mFID, 0, recast(hdrBlock, pDirBlk));
- X if hdrBlock^.oldTest <> nil then
- X begin
- X initHdrBlock;
- X b := 0;
- X end
- X else if hdrBlock^.fileVersion <> curFileVersion then
- X begin
- X makeGoTree;
- X raise badFileVersion;
- X end
- X else
- X b := 1;
- X pd := makePtr(treeSeg, 0, pDirBlk);
- X FSBlkRead(mFID, b, pd);
- X b := b + 1;
- X treeRoot := makePtr(treeSeg, 0, pMRec);
- X with treeRoot^ do
- X begin
- X mBlks := nextMBlock div 256;
- X tBlks := nextTBlock div 256;
- X cBlks := nextCBlock div 512;
- X end;
- X initSegs(mBlks, tBlks, cBlks);
- X for i := 1 to mBlks - 1 do
- X begin
- X pd := makePtr(treeSeg, i * 256, pDirBlk);
- X FSBlkRead(mFID, b, pd);
- X b := b + 1;
- X end;
- X for i := 0 to tBlks - 1 do
- X begin
- X pd := makePtr(tagSeg, i * 256, pDirBlk);
- X FSBlkRead(mFID, b, pd);
- X b := b + 1;
- X end;
- X for i := 0 to cBlks - 1 do
- X begin
- X pd := makePtr(cmtSeg, i * 256, pDirBlk);
- X FSBlkRead(mFID, b, pd);
- X b := b + 1;
- X end;
- X with treeRoot^ do
- X begin
- X if freePool <> nil then
- X begin
- X ph.p := freePool;
- X ph.ps := treeSeg;
- X freePool := ph.p;
- X end;
- X if flink <> nil then
- X begin
- X ph.p := flink;
- X ph.ps := treeSeg;
- X flink := ph.p;
- X end;
- X if lastMove <> nil then
- X begin
- X ph.p := lastMove;
- X ph.ps := treeSeg;
- X lastMove := ph.p;
- X end;
- X if lastTag <> nil then
- X begin
- X ph.pt := lastTag;
- X ph.ps := tagSeg;
- X lastTag := ph.pt;
- X end;
- X if freeTags <> nil then
- X begin
- X ph.pt := freeTags;
- X ph.ps := tagSeg;
- X freeTags := ph.pt;
- X end;
- X end;
- X i := wordSize(moveRec);
- X while i < treeRoot^.nextMRec do
- X begin
- X pm := makePtr(treeSeg, i, pMRec);
- X with pm^ do
- X begin
- X if flink <> nil then
- X begin
- X ph.p := flink;
- X ph.ps := treeSeg;
- X flink := ph.p;
- X end;
- X if blink <> nil then
- X begin
- X ph.p := blink;
- X ph.ps := treeSeg;
- X blink := ph.p;
- X end;
- X if slink <> nil then
- X begin
- X ph.p := slink;
- X ph.ps := treeSeg;
- X slink := ph.p;
- X end;
- X if tag <> nil then
- X begin
- X ph.pt := tag;
- X ph.ps := tagSeg;
- X tag := ph.pt;
- X end;
- X end;
- X i := i + wordSize(moveRec);
- X end;
- X i := 0;
- X while i < treeRoot^.nextTRec do
- X begin
- X tm := makePtr(tagSeg, i, tagPtr);
- X with tm^ do
- X begin
- X if mPtr <> nil then
- X begin
- X ph.p := mPtr;
- X ph.ps := treeSeg;
- X mPtr := ph.p;
- X end;
- X if nextTag <> nil then
- X begin
- X ph.pt := nextTag;
- X ph.ps := tagSeg;
- X nextTag := ph.pt;
- X end;
- X end;
- X i := i + wordSize(tagRec);
- X end;
- X stepTag := nil;
- Xend { readTree };
- X
- Xprocedure writeTree(nam: string; lm: pMRec);
- Xvar
- X pd: pDirBlk;
- X treeBlks, tagBlks, cmtBlks: integer;
- X b, i: integer;
- X
- X procedure compressCmts;
- X var
- X numCmts: integer;
- X cp: pMRec;
- X
- X procedure spanComments(m: pMRec);
- X begin { spanComments }
- X while m <> nil do
- X begin
- X if m^.cmtLen > 0 then
- X begin
- X numCmts := numCmts + 1;
- X cmtCmpArray[numCmts] := m;
- X end;
- X spanComments(m^.slink);
- X m := m^.flink;
- X end;
- X end { spanComments };
- X
- X procedure sortComments;
- X var
- X i, j: integer;
- X t: pMRec;
- X begin { sortComments }
- X for i := 1 to numCmts - 1 do
- X for j := i + 1 to numCmts do
- X if cmtCmpArray[i]^.cmtBase > cmtCmpArray[j]^.cmtBase then
- X begin
- X t := cmtCmpArray[i];
- X cmtCmpArray[i] := cmtCmpArray[j];
- X cmtCmpArray[j] := t;
- X end;
- X end { sortComments };
- X
- X procedure squeezeComments;
- X var
- X i, j, cgi, lastCB: integer;
- X mp: pMRec;
- X begin { squeezeComments }
- X lastCB := 0;
- X for i := 1 to numCmts do
- X begin
- X if cmtCmpArray[i]^.cmtBase > lastCB then
- X begin
- X cgi := cmtCmpArray[i]^.cmtBase;
- X for j := 0 to cmtCmpArray[i]^.cmtLen - 1 do
- X begin
- X {$R-}
- X cmtArray^[lastCB + j] := cmtArray^[cgi + j];
- X {$R=}
- X end;
- X cmtCmpArray[i]^.cmtBase := lastCB;
- X end;
- X lastCB := cmtCmpArray[i]^.cmtBase + cmtCmpArray[i]^.cmtLen;
- X end;
- X treeRoot^.nextCIdx := lastCB;
- X end { squeezeComments };
- X
- X begin { compressCmts }
- X numCmts := 0;
- X cp := treeRoot^.flink;
- X if cp <> nil then
- X begin
- X spanComments(cp);
- X sortComments;
- X squeezeComments;
- X end;
- X end { compressCmts };
- X
- Xbegin { writeTree }
- X mFID := FSEnter(nam);
- X if mFID = 0 then
- X raise badGoWrite
- X else
- X begin
- X compressCmts;
- X with treeRoot^ do
- X begin
- X lastMove := lm;
- X treeBlks := nextMBlock div 256;
- X tagBlks := nextTBlock div 256;
- X cmtBlks := nextCBlock div 512;
- X end;
- X FSBlkWrite(mFID, 0, recast(hdrBlock, pDirBlk));
- X b := 1;
- X for i := 0 to treeBlks - 1 do
- X begin
- X pd := makePtr(treeSeg, i * 256, pDirBlk);
- X FSBlkWrite(mFID, b, pd);
- X b := b + 1;
- X end;
- X for i := 0 to tagBlks - 1 do
- X begin
- X pd := makePtr(tagSeg, i * 256, pDirBlk);
- X FSBlkWrite(mFID, b, pd);
- X b := b + 1;
- X end;
- X for i := 0 to cmtBlks - 1 do
- X begin
- X pd := makePtr(cmtSeg, i * 256, pDirBlk);
- X FSBlkWrite(mFID, b, pd);
- X b := b + 1;
- X end;
- X FSClose(mFID, treeBlks + tagBlks + cmtBlks, 4096);
- X end;
- Xend { writeTree };
- X
- Xfunction newMove(cm: pMRec): pMRec;
- Xvar
- X pm: pMRec;
- Xbegin { newMove }
- X with treeRoot^ do
- X if freePool <> nil then
- X begin
- X pm := freePool;
- X freePool := pm^.flink;
- X end
- X else
- X begin
- X if nextMRec + wordSize(moveRec) > nextMBlock then
- X begin
- X trSegSize := trSegSize + treeSegInc;
- X changeSize(treeSeg, trSegSize);
- X nextMBlock := nextMBlock + (treeSegInc * 256);
- X end;
- X pm := makePtr(treeSeg, nextMRec, pMRec);
- X nextMRec := nextMRec + wordSize(moveRec);
- X end;
- X with pm^ do
- X begin
- X flink := nil;
- X blink := cm;
- X slink := nil;
- X tag := nil;
- X cmtLen := 0;
- X end;
- X if cm^.flink <> nil then
- X pm^.slink := cm^.flink;
- X cm^.flink := pm;
- X newMove := pm;
- Xend { newMove };
- X
- Xprocedure tagMove(cm: pMRec; ts: tagStr);
- Xvar
- X tp: tagPtr;
- Xbegin { tagMove }
- X if cm^.tag <> nil then
- X cm^.tag^.sTag := ts
- X else
- X with treeRoot^ do
- X begin
- X if freeTags <> nil then
- X begin
- X tp := freeTags;
- X freeTags := tp^.nextTag;
- X end
- X else
- X begin
- X if nextTRec + wordSize(tagRec) > nextTBlock then
- X begin
- X tagSegSize := tagSegSize + tagSegInc;
- X changeSize(tagSeg, tagSegSize);
- X nextTBlock := nextTBlock + (tagSegInc * 256);
- X end;
- X tp := makePtr(tagSeg, nextTRec, tagPtr);
- X nextTRec := nextTRec + wordSize(tagRec);
- X end;
- X cm^.tag := tp;
- X with tp^ do
- X begin
- X mPtr := cm;
- X nextTag := lastTag;
- X sTag := ts;
- X end;
- X lastTag := tp;
- X end;
- X treeDirty := true;
- Xend { tagMove };
- X
- Xfunction tagExists(ts: tagStr): boolean;
- Xvar
- X tp: tagPtr;
- X
- X function upCmp(s1, s2: pString): boolean;
- X begin { upCmp }
- X convUpper(s1);
- X convUpper(s2);
- X upCmp := s1 = s2;
- X end { upCmp };
- X
- Xbegin { tagExists }
- X tp := treeRoot^.lastTag;
- X while tp <> nil do
- X if upCmp(tp^.sTag, ts) then
- X begin
- X tagExists := true;
- X exit(tagExists);
- X end
- X else
- X tp := tp^.nextTag;
- X tagExists := false;
- Xend { tagExists };
- X
- Xprocedure commentMove(cm: pMRec; cs: string);
- Xvar
- X sl, i: integer;
- Xbegin { commentMove }
- X if cm = treeRoot then
- X hdrBlock^.rootComment := cs
- X else
- X begin
- X sl := length(cs);
- X with cm^ do
- X begin
- X cmtLen := sl;
- X if sl > 0 then
- X begin
- X cmtBase := treeRoot^.nextCIdx;
- X treeRoot^.nextCIdx := cmtBase + sl;
- X if cmtBase + cmtLen > treeRoot^.nextCBlock then
- X with treeRoot^ do
- X begin
- X cmtSegSize := cmtSegSize + cmtSegInc;
- X changeSize(cmtSeg, cmtSegSize);
- X nextCBlock := nextCBlock + (cmtSegInc * 512);
- X end;
- X for i := 0 to sl - 1 do
- X begin
- X{$R-}
- X cmtArray^[cmtBase + i] := cs[i + 1];
- X{$R=}
- X end;
- X end;
- X end;
- X end;
- X treeDirty := true;
- Xend { commentMove };
- X
- Xfunction getComment(cm: pMRec; var cs: string): boolean;
- Xvar
- X i: integer;
- Xbegin { getComment }
- X if cm = treeRoot then
- X begin
- X cs := hdrBlock^.rootComment;
- X getComment := cs <> '';
- X end
- X else if cm^.cmtLen = 0 then
- X getComment := false
- X else
- X with cm^ do
- X begin
- X getComment := true;
- X adjust(cs, cmtLen);
- X for i := 1 to cmtLen do
- X begin
- X{$R-}
- X cs[i] := cmtArray^[cmtBase + i - 1];
- X{$R=}
- X end;
- X end;
- Xend { getComment };
- X
- Xfunction getTag(cm: pMRec; var ts: string): boolean;
- Xbegin { getTag }
- X if cm = treeRoot then
- X getTag := false
- X else if cm^.tag = nil then
- X getTag := false
- X else
- X begin
- X ts := cm^.tag^.sTag;
- X getTag := true;
- X end;
- Xend { getTag };
- X
- Xprocedure delTag(tp: tagPtr);
- Xvar
- X ttp: tagPtr;
- Xbegin { delTag }
- X tp^.mPtr^.tag := nil;
- X tp^.mPtr := nil;
- X if stepTag = tp then
- X stepTag := nil;
- X ttp := treeRoot^.lastTag;
- X if ttp = tp then
- X treeRoot^.lastTag := tp^.nextTag
- X else
- X begin
- X while ttp^.nextTag <> tp do
- X ttp := ttp^.nextTag;
- X ttp^.nextTag := tp^.nextTag;
- X end;
- X tp^.nextTag := treeRoot^.freeTags;
- X treeRoot^.freeTags := tp;
- Xend { delTag };
- X
- Xfunction delBranch(pm: pMRec): pMRec;
- Xvar
- X sm: pMRec;
- X
- X procedure recDel(m: pMRec);
- X var
- X tp: tagPtr;
- X begin { recDel }
- X if m <> nil then
- X begin
- X recDel(m^.slink);
- X recDel(m^.flink);
- X m^.blink := nil;
- X m^.slink := nil;
- X m^.flink := treeRoot^.freePool;
- X treeRoot^.freePool := m;
- X if m^.tag <> nil then
- X delTag(m^.tag);
- X end;
- X end { recDel };
- X
- Xbegin { delBranch }
- X if pm = treeRoot then
- X exit(delBranch);
- X while pm^.id = remove do
- X pm := pm^.blink;
- X if pm^.blink^.flink = pm then
- X pm^.blink^.flink := pm^.slink
- X else
- X begin
- X sm := pm^.blink^.flink;
- X while sm^.slink <> pm do
- X sm := sm^.slink;
- X sm^.slink := pm^.slink;
- X end;
- X pm^.slink := nil;
- X delBranch := pm^.blink;
- X pm^.blink := nil;
- X recDel(pm);
- Xend { delBranch };
- X
- Xprocedure delNode(pm: pMRec);
- Xvar
- X sm: pMRec;
- Xbegin { delNode }
- X if pm = treeRoot then
- X exit(delNode);
- X if pm^.blink^.flink = pm then
- X pm^.blink^.flink := pm^.slink
- X else
- X begin
- X sm := pm^.blink^.flink;
- X while sm^.slink <> pm do
- X sm := sm^.slink;
- X sm^.slink := pm^.slink;
- X end;
- X pm^.blink := nil;
- X pm^.slink := nil;
- X pm^.flink := treeRoot^.freePool;
- X treeRoot^.freePool := pm;
- Xend { delNode };
- X
- Xfunction mergeMove(cm: pMRec): pMRec;
- Xvar
- X tm: pMRec;
- Xbegin { mergeMove }
- X tm := cm^.blink^.flink;
- X mergeMove := cm;
- X while tm <> nil do
- X begin
- X if tm <> cm then
- X with tm^ do
- X if id = cm^.id then
- X if id = hcPlay then
- X begin
- X mergeMove := tm;
- X delNode(cm);
- X exit(mergeMove);
- X end
- X else if id = pass then
- X begin
- X if who = cm^.who then
- X begin
- X mergeMove := tm;
- X delNode(cm);
- X exit(mergeMove);
- X end;
- X end
- X else if (mx = cm^.mx) and
- X (my = cm^.my) and
- X (who = cm^.who) then
- X begin
- X mergeMove := tm;
- X delNode(cm);
- X exit(mergeMove);
- X end;
- X tm := tm^.slink;
- X end;
- X treeDirty := true;
- Xend { mergeMove };
- X
- Xfunction hasAlts(pm: pMRec): boolean;
- Xbegin { hasAlts }
- X while pm^.id = remove do
- X pm := pm^.blink;
- X hasAlts := pm^.blink^.flink^.slink <> nil;
- Xend { hasAlts };
- X
- Xprocedure initGoTree;
- Xbegin { initGoTree }
- X treeSeg := -1;
- X new(0, 256, hdrBlock);
- Xend. { initGoTree }
- END_OF_goTree.pas
- if test 19784 -ne `wc -c <goTree.pas`; then
- echo shar: \"goTree.pas\" unpacked with wrong size!
- fi
- # end of overwriting check
- fi
- echo shar: End of archive 3 \(of 5\).
- cp /dev/null ark3isdone
- MISSING=""
- for I in 1 2 3 4 5 ; do
- if test ! -f ark${I}isdone ; then
- MISSING="${MISSING} ${I}"
- fi
- done
- if test "${MISSING}" = "" ; then
- echo You have unpacked all 5 archives.
- rm -f ark[1-9]isdone
- else
- echo You still need to unpack the following archives:
- echo " " ${MISSING}
- fi
- ## End of shell archive.
- exit 0
-